home *** CD-ROM | disk | FTP | other *** search
/ Amiga Format CD 41 / Amiga Format CD41 (1999-06)(Future Publishing)(GB)[!][issue 1999-07].iso / -seriously_amiga- / programming / other / scm / slib / record.scm < prev    next >
Text File  |  1999-04-19  |  7KB  |  229 lines
  1. ; "record.scm" record data types
  2. ; Written by David Carlton, carlton@husc.harvard.edu.
  3. ; Re-Written by Aubrey Jaffer, jaffer@ai.mit.edu, 1996, 1997
  4. ;
  5. ; This code is in the public domain.
  6.  
  7. ; Implements `record' data structures for Scheme.  Using only the
  8. ; opacity of procedures, makes record datatypes and
  9. ; record-type-descriptors disjoint from R4RS types and each other, and
  10. ; prevents forgery and corruption (modification without using
  11. ; RECORD-MODIFIER) of records.
  12.  
  13. (require 'common-list-functions)
  14.  
  15. (define vector? vector?)
  16. (define vector-ref vector-ref)
  17. (define vector-set! vector-set!)
  18. (define vector-fill! vector-fill!)
  19. (define vector->list vector->list)
  20. (define display display)
  21. (define write write)
  22.  
  23. (define record-modifier #f)
  24. (define record-accessor #f)
  25. (define record-constructor #f)
  26. (define record-predicate #f)
  27. (define make-record-type #f)
  28.  
  29. (let (;; Need to close these to keep magic-cookie hidden.
  30.       (make-vector make-vector)
  31.       (vector vector)
  32.  
  33.       ;; We have to wrap these to keep magic-cookie hidden.
  34.       (vect? vector?)
  35.       (vect-ref vector-ref)
  36.       (vect->list vector->list)
  37.       (disp display)
  38.       (wri write)
  39.  
  40.       ;; Need to wrap these to protect record data from being corrupted.
  41.       (vect-set! vector-set!)
  42.       (vect-fill! vector-fill!)
  43.  
  44.       (nvt "of non-vector type")
  45.       )
  46.   (letrec
  47.       (;; Tag to identify rtd's.  (A record is identified by the rtd
  48.        ;; that begins it.)
  49.        (magic-cookie (cons 'rtd '()))
  50.        (rtd? (lambda (object)
  51.            (and (vect? object)
  52.             (not (= (vector-length object) 0))
  53.             (eq? (rtd-tag object) magic-cookie))))
  54.        (rec? (lambda (obj)
  55.            (and (vect? obj)
  56.             (>= (vector-length obj) 1)
  57.             (or (eq? magic-cookie (rec-rtd obj))
  58.             (rtd? (rec-rtd obj))))))
  59.  
  60.        (vec:error
  61.     (lambda (proc-name msg obj)
  62.       (slib:error proc-name msg
  63.               (cond ((rtd? obj) 'rtd)
  64.                 ((rec? obj) (rtd-name (rec-rtd obj)))
  65.                 (else obj)))))
  66.  
  67.        ;; Internal accessor functions.  No error checking.
  68.        (rtd-tag (lambda (x) (vect-ref x 0)))
  69.        (rtd-name (lambda (rtd) (if (vector? rtd) (vect-ref rtd 1) "rtd")))
  70.        (rtd-fields (lambda (rtd) (vect-ref rtd 3)))
  71.        ;; rtd-vfields is padded out to the length of the vector, which is 1
  72.        ;; more than the number of fields
  73.        (rtd-vfields (lambda (rtd) (cons #f (rtd-fields rtd))))
  74.        ;; rtd-length is the length of the vector.
  75.        (rtd-length (lambda (rtd) (vect-ref rtd 4)))
  76.  
  77.        (rec-rtd (lambda (x) (vect-ref x 0)))
  78.        (rec-disp-str
  79.     (lambda (x)
  80.       (let ((name (rtd-name (rec-rtd x))))
  81.         (string-append
  82.          "#<" (if (symbol? name) (symbol->string name) name) ">"))))
  83.  
  84.        (make-rec-type
  85.     (lambda (type-name field-names)
  86.       (if (not (or (symbol? type-name) (string? type-name)))
  87.           (slib:error 'make-record-type "non-string type-name argument."
  88.               type-name))
  89.       (if (or (and (list? field-names) (comlist:has-duplicates? field-names))
  90.           (comlist:notevery symbol? field-names))
  91.           (slib:error 'make-record-type "illegal field-names argument."
  92.               field-names))
  93.       (let* ((augmented-length (+ 1 (length field-names)))
  94.          (rtd (vector magic-cookie
  95.                   type-name
  96.                   '()
  97.                   field-names
  98.                   augmented-length
  99.                   #f
  100.                   #f)))
  101.         (vect-set! rtd 5
  102.                (lambda (x)
  103.              (and (vect? x)
  104.                   (= (vector-length x) augmented-length)
  105.                   (eq? (rec-rtd x) rtd))))
  106.         (vect-set! rtd 6
  107.                (lambda (x)
  108.              (and (vect? x)
  109.                   (>= (vector-length x) augmented-length)
  110.                   (eq? (rec-rtd x) rtd)
  111.                   #t)))
  112.         rtd)))
  113.  
  114.        (rec-predicate
  115.     (lambda (rtd)
  116.       (if (not (rtd? rtd))
  117.           (slib:error 'record-predicate "invalid argument." rtd))
  118.       (vect-ref rtd 5)))
  119.  
  120.        (rec-constructor
  121.     (lambda (rtd . field-names)
  122.       (if (not (rtd? rtd))
  123.           (slib:error 'record-constructor "illegal rtd argument." rtd))
  124.       (if (or (null? field-names)
  125.           (equal? field-names (rtd-fields rtd)))
  126.           (let ((rec-length (- (rtd-length rtd) 1)))
  127.         (lambda elts
  128.           (if (= (length elts) rec-length) #t
  129.               (slib:error 'record-constructor
  130.                   (rtd-name rtd)
  131.                   "wrong number of arguments."))
  132.           (apply vector rtd elts)))
  133.           (let ((rec-vfields (rtd-vfields rtd))
  134.             (corrected-rec-length (rtd-length rtd))
  135.             (field-names (car field-names)))
  136.         (if (or (and (list? field-names) (comlist:has-duplicates? field-names))
  137.             (comlist:notevery (lambda (x) (memq x rec-vfields))
  138.                       field-names))
  139.             (slib:error
  140.              'record-constructor "invalid field-names argument."
  141.              (cdr rec-vfields)))
  142.         (let ((field-length (length field-names))
  143.               (offsets
  144.                (map (lambda (field) (comlist:position field rec-vfields))
  145.                 field-names)))
  146.           (lambda elts
  147.             (if (= (length elts) field-length) #t
  148.             (slib:error 'record-constructor
  149.                     (rtd-name rtd)
  150.                     "wrong number of arguments."))
  151.             (let ((result (make-vector corrected-rec-length)))
  152.               (vect-set! result 0 rtd)
  153.               (for-each (lambda (offset elt)
  154.                   (vect-set! result offset elt))
  155.                 offsets
  156.                 elts)
  157.               result)))))))
  158.  
  159.        (rec-accessor
  160.     (lambda (rtd field-name)
  161.       (if (not (rtd? rtd))
  162.           (slib:error 'record-accessor "invalid rtd argument." rtd))
  163.       (let ((index (comlist:position field-name (rtd-vfields rtd)))
  164.         (augmented-length (rtd-length rtd)))
  165.         (if (not index)
  166.         (slib:error 'record-accessor "invalid field-name argument."
  167.                 field-name))
  168.         (lambda (x)
  169.           (if (and (vect? x)
  170.                (>= (vector-length x) augmented-length)
  171.                (eq? rtd (rec-rtd x)))
  172.           #t
  173.           (slib:error 'record-accessor "wrong record type." x "not" rtd))
  174.           (vect-ref x index)))))
  175.  
  176.        (rec-modifier
  177.     (lambda (rtd field-name)
  178.       (if (not (rtd? rtd))
  179.           (slib:error 'record-modifier "invalid rtd argument." rtd))
  180.       (let ((index (comlist:position field-name (rtd-vfields rtd)))
  181.         (augmented-length (rtd-length rtd)))
  182.         (if (not index)
  183.         (slib:error 'record-modifier "invalid field-name argument."
  184.                 field-name))
  185.         (lambda (x y)
  186.           (if (and (vect? x)
  187.                (>= (vector-length x) augmented-length)
  188.                (eq? rtd (rec-rtd x)))
  189.           #t
  190.           (slib:error 'record-modifier "wrong record type." x "not" rtd))
  191.           (vect-set! x index y)))))
  192.        )
  193.  
  194.     (set! vector? (lambda (obj) (and (not (rec? obj)) (vect? obj))))
  195.     (set! vector-ref
  196.       (lambda (vector k)
  197.         (cond ((rec? vector)
  198.            (vec:error 'vector-ref nvt vector))
  199.           (else (vect-ref vector k)))))
  200.     (set! vector->list
  201.       (lambda (vector)
  202.         (cond ((rec? vector)
  203.            (vec:error 'vector->list nvt vector))
  204.           (else (vect->list vector)))))
  205.     (set! vector-set!
  206.       (lambda (vector k obj)
  207.         (cond ((rec? vector)
  208.            (vec:error 'vector-set! nvt vector))
  209.           (else (vect-set! vector k obj)))))
  210.     (set! vector-fill!
  211.       (lambda (vector fill)
  212.         (cond ((rec? vector)
  213.            (vec:error 'vector-fill! nvt vector))
  214.           (else (vect-fill! vector fill)))))
  215.     (set! display
  216.       (lambda (obj . opt)
  217.         (apply disp (if (rec? obj) (rec-disp-str obj) obj) opt)))
  218.     (set! write
  219.       (lambda (obj . opt)
  220.         (if (rec? obj)
  221.         (apply disp (rec-disp-str obj) opt)
  222.         (apply wri obj opt))))
  223.     (set! record-modifier rec-modifier)
  224.     (set! record-accessor rec-accessor)
  225.     (set! record-constructor rec-constructor)
  226.     (set! record-predicate rec-predicate)
  227.     (set! make-record-type make-rec-type)
  228.     ))
  229.